#!/usr/bin/perl

use strict;
use CGI;
use lib '.';
use lib "locallib/Net-OpenID-Consumer/lib";
use lib "locallib/Net-OpenID-Server/lib";
use lib "locallib/Net-Yadis-Discovery/lib";
use warnings;
use Net::OpenID::Server;
use Net::OpenID::Consumer;

my $HAVE_PARANOID_AGENT = 0;
BEGIN {
  $HAVE_PARANOID_AGENT = eval "use LWPx::ParanoidAgent; 1;";
  unless ($HAVE_PARANOID_AGENT) {
    warn "WARNING: running without LWPx::ParanoidAgent; not installed?\n";
  }
}

my $q = CGI->new;
my $path_info = $ENV{PATH_INFO} || "";

my $base = "http://$ENV{HTTP_HOST}";
if ($ENV{HTTP_HOST} !~ /:/ && $ENV{SERVER_PORT} != 80) {
    $base .= ":$ENV{SERVER_PORT}";
}
$base .= $ENV{SCRIPT_NAME};
$base =~ s!/$!!;

my $server = HTTP::Server::OpenIDTest->new;
$server->set_base($base);
$server->handle_request($q);

############################################################################

package HTTP::Server::OpenIDTest;
use strict;

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    if ($ENV{MEMCACHE}) {
        eval "use Cache::Memcached; 1" or die "Don't have Cache::Memcached: $!";
        $self->{rpcache} = Cache::Memcached->new(servers => [$ENV{MEMCACHE}]);
    } else {
        $self->{rpcache} = SimpleCache->new("/tmp/openidtest.rpcache");
    }
    return $self;
}

sub server_secret { return "sdkjsdf_not_so_secret"; }
sub consumer_secret { return "consumer_not_so_secret"; }

sub setup_versions {
    my ($self, $openid_obj) = @_;
    if (! $self->version1) {
        $openid_obj->disable_version_1 if $openid_obj->can('disable_version_1');
    }
    if (! $self->version2) {
        $openid_obj->disable_version_2 if $openid_obj->can('disable_version_2');
    }
}

sub print_banner {
    my $self = shift;
    print "You can now connect to your server at: $self->{base}/\n";
}

sub method {
    my ($self, $val) = @_;
    $self->{method} = $val if defined $val;
    return $self->{method};
}

sub handle_request {
    my ($self, $cgi) = @_;

    my $base = $self->base;
    my $path = $cgi->path_info;
    if ($path =~ m!^/caps!) {
        return $self->handle_caps_request($cgi);
    }

    unless ($path =~ m!^/([\d\.\,]+)/(identity|op|rp|recv_sig|are_you_sure)(.*)!) {
        print $cgi->header, "Welcome to the Perl library's OpenID interoptest server.  I'm part of the <a href='http://code.google.com/p/openid-test/'>openid-test project</a>.  Check out my <a href='$base/caps'>capabilities document</a>.";
        my $out = sub {
            my ($url, $text) = @_;
            my $display_url = $url;
            $display_url =~ s!^\Q$base\E!!;
            print "<li><a href='$url'>$display_url</a> - $text</li>\n";
        };
        my $id_urls = sub {
            my $path = shift;
            $out->("$base/1.1/identity/$path", "Version 1.1 only");
            $out->("$base/1.1/identity/$path/redirect", "Version 1.1 only (redirecting to same, without redirect)");
            $out->("$base/2.0/identity/$path", "Version 2.0 only");
            $out->("$base/1.1,2.0/identity/$path", "Version 1.1+2.0");

            $out->("$base/1.1/identity/$path/delegate_to/1.1", "delegated with 1.1 markup to 1.1 server");
            $out->("$base/2.0/identity/$path/delegate_to/2.0", "delegated with 2.0 markup to 2.0 server");
            $out->("$base/1.1,2.0/identity/$path/delegate_to/1.1,2.0", "delegated with 1.1+2.0 markup to 1.1+2.0 server");

            $out->("$base/1.1/identity/$path/delegate_to/2.0", "delegated with 1.1 markup to 2.0 server");
            $out->("$base/2.0/identity/$path/delegate_to/1.1", "delegated with 2.0 markup to 1.1 server");

        };
        print "<ul>";

        print "<li>Relying party (consumer) URLs:<ul>\n";
        $out->("$base/1.1/rp", "Relying party which only knows 1.1");
        $out->("$base/2.0/rp", "Relying party which only knows 2.0");
        $out->("$base/1.1,2.0/rp", "Relying party which does 1.1 and 2.0");
        print "</ul></li>\n";

        print "<li>Identity URLs which return signatures right away:<ul>";
        $id_urls->("will-sign");
        print "</ul></li>\n";

        print "<li>Identity URLs which fail, but after setup succeed.<ul>";
        $id_urls->("will-setup-then-sign");
        print "</ul></li>\n";

        print "<li>Identity URLs which fail, and then after setup do openid.mode=cancel.<ul>";
        $id_urls->("will-setup-then-cancel");
        print "</ul></li>\n";

        print "</ul>";

        print "Libraries I'm using: <ul>", $self->libraries_version, "</ul>";
        return;
    }
    my ($versions, $mode, $rest) = ($1, $2, $3);
    my %versions = map { $_ => 1 } split(/,/, $versions);
    $self->{version_list} = $versions;
    $self->{versions} = \%versions;

    my $method = "handle_${mode}_request";
    my $rv = eval { $self->$method($cgi, $rest); };
    return $rv unless $@;
    if ($@) {
        $cgi->header("text/html");
        print "ERROR: $@\n";
        return;
    }
}

sub libraries_version {
    my($self) = @_;

    my $html;
    for my $library (qw( Net::OpenID::Consumer Net::OpenID::Server Net::Yadis::Discovery )) {
        (my $fn = $library) =~ s!::!/!g;
        $html .= "<li>" . $library . ": " .($INC{"$fn.pm"} ? $library->VERSION : '(N/A)') . "</li>";
    }

    return $html;
}

sub handle_caps_request {
    my ($self, $cgi, $rest) = @_;
    print $cgi->header("text/plain");
    print "# I am an openid-test capabilities document.\n# I support the following:\n\n";
    print "openid1.1\n";
    print "openid2.0\n";
    print "disableopenid1.1\n";

    print "#xri\n";
}

sub handle_identity_request {
    my ($self, $cgi, $rest) = @_;
    my $base = $self->base;

    my $delegate = 0;
    my $delegate_to_version;
    if ($rest =~ m!/delegate_to/([\d\.\,]+)!) {
        $delegate = 1;
        $delegate_to_version = $1;
    }

    if ($rest =~ s!/redirect!!) {
        print $cgi->redirect($self->base_with_versions . "/identity$rest");
        return;
    }

    print $cgi->header;
    print "<html><head>\n";
    if ($self->version1) {
        if ($delegate) {
            my $non_delegated_url = $self->base_with_versions . "/identity" . $rest;
            $non_delegated_url =~ s!/delegate_to/.*!!;
            print qq{<link rel="openid.server" href="$base/$delegate_to_version/op" />\n};
            print qq{<link rel="openid.delegate" href="$non_delegated_url" />\n};
        } else {
            print qq{<link rel="openid.server" href="$base/1.1/op" />\n};
        }
    }
    if ($self->version2) {
        if ($delegate) {
            my $non_delegated_url = $self->base_with_versions . "/identity" . $rest;
            $non_delegated_url =~ s!/delegate_to/.*!!;
            print qq{<link rel="openid2.provider" href="$base/$delegate_to_version/op" />\n};
            print qq{<link rel="openid2.local_id" href="$non_delegated_url" />\n};
        } else {
            print qq{<link rel="openid2.provider" href="$base/2.0/op" />\n};
        }
    }

    print "</head><body>This is an OpenID user's URL which supports protocol version(s): " . $self->{version_list} . "</body></html>";

}

sub consumer_cache {
  my $self = shift;
  return undef;  # TODO: return real cache object
}

sub handle_recv_sig_request {
    my ($self, $cgi, $rest) = @_;

    my $cache = $self->consumer_cache;
    my $base = $self->base;
    my $csr = Net::OpenID::Consumer->new
        (
         ua    => $HAVE_PARANOID_AGENT ? LWPx::ParanoidAgent->new : undef,
         cache => $self->{rpcache},
         args  => $cgi,
         consumer_secret => $self->consumer_secret,
         required_root => $base,
         debug => 1,
         );
    $self->setup_versions($csr);

    print $cgi->header("text/plain");
    if (my $setup_url = $csr->user_setup_url) {
      print "setup_url: $setup_url\n";
    } elsif ($csr->user_cancel) {
      print "user_cancel: 1\n";
    } elsif (my $vident = $csr->verified_identity) {
      my $verified_url = $vident->url;
      print "OK # $verified_url\n";
    } else {
      print "error: ", $csr->err, "\n";
    }

    return;
}

sub handle_op_request {
    my ($self, $cgi, $rest) = @_;

    my $actual_user;
    my $ident_url;

    my $nos = Net::OpenID::Server->new
      (
       get_args     => $cgi,
       post_args    => $cgi,
       get_user     => sub {
         # this just needs to be true.  we ignore it elsewhere.
         return {"DUMMY_OBJECT"=>"IS_DUMMY"};
       },
       is_identity  => sub {
         my ($dummy_u, $url) = @_;
         $ident_url = $url;

         return 0 if $url =~ /\bdelegate_to\b/;

         if ($url =~ m!/identity/(will-[\w\-]+)!) {
           $actual_user = $1;
           return 1;
         }
         return 0;
       },
       is_trusted   => sub {
         my ($dummy_u, $realm, $is_identity) = @_;
         if ($actual_user eq "will-sign") {
           return 1;
         }
         return 0;
       },
       setup_url     => $self->base_with_versions . "/are_you_sure",
       server_secret => $self->server_secret,
       );
    $self->setup_versions($nos);

    my ($type, $data) = $nos->handle_page(redirect_for_setup => 1);
    if ($type eq "redirect") {
      print $cgi->redirect($data);
    } else {
        print $cgi->header(-Content_length => length($data),
                           -type => $type);
        print $data;
    }
}

sub handle_rp_request {
    my ($self, $cgi, $rest) = @_;

    my $method = $cgi->request_method;
    my $oid = $cgi->param("openid_identifier");
    unless ($oid) {
      print $cgi->header;
      print "This RP will use protocol versions: $self->{version_list}<p>";
      print qq{<form method='get'>OpenID URL to test: <input type='text' size=50 name='openid_identifier' /><input type=submit value='Proceed'/> <input type=reset value='Clear'/>
                     <div class='options'>
                   Operation: <select name='op'>
                   <option value=''>Everything (full OpenID flow)</option>
                   <option value='disco'>Return discovery information</option>
                   <option value='assoc'>Return association details</option>
                   </select><br/>
                   Association mode: <select name='assoc_mode'>
                   <option value='stateful'>Stateful, possibly cached.</option>
                   <option value='stateful_new'>Stateful, create new association.</option>
                   <option value='stateless'>Don\'t association (dumb mode)</option>
                   <option value='use_handle'>Use specific association handle: </option>
                   </select> Specific handle: <input name='assoc_handle' /><br/>
                     </div>
                     </form>};
      return;
    }

    my $assoc_mode = $cgi->param("assoc_mode") || "stateful";
    my $cache;
    if ($assoc_mode eq "stateless") {
        $cache = undef;
    } else {
        $cache = $self->{rpcache};
    }

    my $base = $self->base;
    my $csr = Net::OpenID::Consumer->new
        (
         ua    => $HAVE_PARANOID_AGENT ? LWPx::ParanoidAgent->new : undef,
         cache => $cache,
         args  => $cgi,
         consumer_secret => $self->consumer_secret,
         required_root => $base,
         );
    $self->setup_versions($csr);

    my $claimed_id = $csr->claimed_identity($oid);
    unless ($claimed_id) {
        print $cgi->header("text/plain");
        print "# ", $csr->err;
        return;
    }

    my $op = $cgi->param("op") || "";

    if ($op eq "disco") {
        print $cgi->header("text/plain");
        if ($claimed_id) {
            print "user_specified_url: ", $claimed_id->claimed_url, "\n";
            print "openid_provider: ", $claimed_id->identity_server, "\n";
            print "local_id: ", ($claimed_id->delegated_url || ""), "\n";
        }
        return;
    }

    my $return_assoc = $op eq "assoc";

    # use an explicit association?
    my $use_assoc;
    if ($assoc_mode eq "use_handle") {
        $use_assoc = $cgi->param("assoc_handle");
    }

    my $check_url = $claimed_id->check_url
      (
       delayed_return => 1,
       return_to      => $self->base_with_versions . "/recv_sig",
       trust_root     => $self->base_with_versions,
       use_assoc_handle => $use_assoc,
       actually_return_association => $return_assoc,
       force_reassociate => ($assoc_mode eq "stateful_new"),
      );

    if ($return_assoc) {
        my $assoc = $check_url;  # return value type changes when flag is set.
        print $cgi->header("text/plain");
        if ($assoc) {
            print "handle: ", $assoc->handle, "\n";
            print "type: ", $assoc->type, "\n";
        } else {
            print "# no association\n";
        }
        return;
    }

    print $cgi->redirect($check_url);
}

sub handle_are_you_sure_request {
    my ($self, $cgi, $rest) = @_;
    my $identity = $cgi->param("identity");

    if ($identity =~ /\bdelegate_to\b/) {
        print $cgi->header("text/html");
        print "ERROR: can't are-you-sure on identities doing delegation";
        return;
    }

    my ($which) = $identity =~ m!/identity/(will-[\w\-]+)!;

    my $nos = Net::OpenID::Server->new
      (
       get_args     => $cgi,
       post_args    => $cgi,
       server_secret => $self->server_secret,
      );
    $self->setup_versions($nos);

    if ($which eq "will-setup-then-sign") {
      print $cgi->redirect($nos->signed_return_url
                           (
                            identity     => $cgi->param('identity'),
                            return_to    => $cgi->param('return_to'),
                            trust_root   => $cgi->param('trust_root'),
                            assoc_handle => $cgi->param('assoc_handle'),
                           ));
      return;
    }

    if ($which eq "will-setup-then-cancel") {
      print $cgi->redirect($nos->cancel_return_url
                           (
                            return_to    => $cgi->param('return_to'),
                            ));
      return;
    }

    print $cgi->header("text/html");
    print "ERROR: unsupported identity URL ($which)";
}


#### subclass-specific

sub set_base {
    my ($self, $base) = @_;
    $self->{base} = $base;
}

sub base { return $_[0]{base} }

sub base_with_versions { return $_[0]{base} . "/". $_[0]{version_list}; }

sub version1 { return $_[0]{versions}{"1.1"} }
sub version2 { return $_[0]{versions}{"2.0"} }

############################################################################
package SimpleCache;
BEGIN { @AnyDBM_File::ISA = qw( GDBM_File DB_File NDBM_File SDBM_File ) }
use AnyDBM_File;
use POSIX;

my $flag;
BEGIN {
    eval { require GDBM_File; GDBM_File->import };
    $flag = $@ ? (O_CREAT | O_RDWR) : &GDBM_WRCREAT;
}

sub new {
    my ($class, $file) = @_;
    my %tied;
    tie %tied, 'AnyDBM_File', $file, $flag, 0640 or die "$file: $!";
    return bless { db => \%tied };
}

sub set {
    my ($self, $key, $val) = @_;
    $self->{db}{$key} = $val;
}

sub get {
    my ($self, $key) = @_;
    return $self->{db}{$key};
}

